home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
QRZ! Ham Radio 8
/
QRZ Ham Radio Callsign Database - Volume 8.iso
/
pc
/
files
/
ant_nec
/
nec81tar.z
/
nec81tar
/
nfpat.f
< prev
next >
Wrap
Text File
|
1991-05-13
|
17KB
|
623 lines
C $TITLE: 'NFPAT'
C $NOFLOATCALLS
C
C
C
SUBROUTINE NFPAT(X,Y,Z,SI,BI,SALP,
1 T1X,T1Y,T1Z,T2X,T2Y,T2Z,ICON1,ICON2,
2 AIR,AII,BIR,BII,CIR,CII,CUR,IW,LD,LD3)
C COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS
REAL*8 TA,CANG,CTH,STH,CPH,SPH,TMP1,TMP2,TMP3,XOB,YOB,ZOB
REAL*8 AIR,AII,BIR,BII,CIR,CII
CLARGE:CUR
COMPLEX CUR
COMPLEX*16 EX,EY,EZ
INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
COMMON/FPAT/NTH,NPH,IPD,IAVP,INOR,IAX,THETS,PHIS,DTH,DPH,RFLD,
1 GNOR,CLT,CHT,EPSR2,SIG2,IXTYP,XPR6,PINR,PNLR,PLOSS,NEAR,NFEH,
2 NRX,NRY,NRZ,XNR,YNR,ZNR,DXNR,DYNR,DZNR
C***
COMMON/PLOT/ IPLP1,IPLP2,IPLP3,IPLP4
C***
DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
DIMENSION CUR(LD3),ICON1(LD),ICON2(LD)
C***
C*** PEAK FIELDS - ADD RPD RWA 02 APR 89
C***
DATA TA/1.745329252D-02/,RPD/57.29577951/
C**
C D WRITE(*,*) ' NFPAT: START'
C**
IF (NFEH.EQ.1) GO TO 1
WRITE(IW,10)
GO TO 2
1 WRITE(IW,12)
2 ZNRT=ZNR-DZNR
DO 9 I=1,NRZ
ZNRT=ZNRT+DZNR
IF (NEAR.EQ.0) GO TO 3
CTH=DCOS(TA*ZNRT)
STH=DSIN(TA*ZNRT)
3 YNRT=YNR-DYNR
DO 9 J=1,NRY
YNRT=YNRT+DYNR
IF (NEAR.EQ.0) GO TO 4
CPH=DCOS(TA*YNRT)
SPH=DSIN(TA*YNRT)
4 XNRT=XNR-DXNR
DO 9 KK=1,NRX
XNRT=XNRT+DXNR
IF (NEAR.EQ.0) GO TO 5
XOB=XNRT*STH*CPH
YOB=XNRT*STH*SPH
ZOB=XNRT*CTH
GO TO 6
5 XOB=XNRT
YOB=YNRT
ZOB=ZNRT
6 TMP1=XOB/WLAM
TMP2=YOB/WLAM
TMP3=ZOB/WLAM
IF (NFEH.EQ.1) GO TO 7
CALL NEFLD (TMP1,TMP2,TMP3,EX,EY,EZ,LD,LD3,X,Y,Z,SI,BI,
1 SALP,T1Y,T1Z,T1X,T1Y,T1Z,T2X,T2Y,T2Z,ICON1,ICON2,AIR,AII,
2 BIR,BII,CIR,CII,CUR)
GO TO 8
7 CALL NHFLD (TMP1,TMP2,TMP3,EX,EY,EZ,LD,LD3,X,Y,Z,SI,BI,
1 SALP,T1Y,T1Z,T1X,T1Y,T1Z,T2X,T2Y,T2Z,AIR,AII,
2 BIR,BII,CIR,CII,CUR)
C8 TMP1=CABS(EX)
8 TMP1=ZABS(EX)
TMP2=CANG(EX)
C TMP3=CABS(EY)
TMP3=ZABS(EY)
TMP4=CANG(EY)
C TMP5=CABS(EZ)
TMP5=ZABS(EZ)
TMP6=CANG(EZ)
C***
C*** PEAK FLD CALCULATION RWA 02 APR 89 ADD 10 LINES/CHANGE 1
C***
EZ2 = TMP5*TMP5
EY2 = TMP3*TMP3
EX2 = TMP1*TMP1
AT = EZ2*COS(TMP6*2./RPD)+EY2*COS(TMP4*2./RPD)
1 +EX2*COS(TMP2*2./RPD)
BT = EZ2*SIN(TMP6*2./RPD)+EY2*SIN(TMP4*2./RPD)
1 +EX2*SIN(TMP2*2./RPD)
CT = AT*AT+BT*BT
ETOTAL = 0.5*(EZ2+EY2+EX2)+0.5*SQRT(CT)
ETOTAL = SQRT(ETOTAL)
WRITE(IW,11) XOB,YOB,ZOB,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,ETOTAL
CCC WRITE(IW,11) XOB,YOB,ZOB,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6
C***
IF(IPLP1 .NE. 2) GO TO 9
GO TO (14,15,16),IPLP4
14 XXX=XOB
GO TO 17
15 XXX=YOB
GO TO 17
16 XXX=ZOB
17 CONTINUE
IF(IPLP2 .NE. 2) GO TO 13
IF(IPLP3 .EQ. 1) WRITE(8,*) XXX,TMP1,TMP2
IF(IPLP3 .EQ. 2) WRITE(8,*) XXX,TMP3,TMP4
IF(IPLP3 .EQ. 3) WRITE(8,*) XXX,TMP5,TMP6
IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6
C***
C*** PEAK FIELDS OUTPUT RWA 02 APR 89 ADD 1 LINE
C***
IF(IPLP3 .EQ. 5) WRITE(8,*) XXX,ETOTAL
GO TO 9
13 IF(IPLP2 .NE. 1) GO TO 9
IF(IPLP3 .EQ. 1) WRITE(8,*) XXX,EX
IF(IPLP3 .EQ. 2) WRITE(8,*) XXX,EY
IF(IPLP3 .EQ. 3) WRITE(8,*) XXX,EZ
IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,EX,EY,EZ
C***
9 CONTINUE
C**
C D WRITE(*,*) ' NFPAT: RETURN'
C**
RETURN
C
C***
C*** PEAK FIELDS PRINTOUT FORMAT RWA 02 APR 89 CHANGE 17 LINES
C***
10 FORMAT (///,35X,32H- - - NEAR ELECTRIC FIELDS - - -,//,12X,14H- L
1OCATION -,21X,8H- EX -,15X,8H- EY -,15X,8H- EZ -,10X,'- PEA
|K FIELDS -'/,8X,1HX,10X,
21HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHASE,
36X,9HMAGNITUDE,3X,5HPHASE,9X,9HMAGNITUDE/,6X,6HMETERS,5X,6HMETERS
|,5X,6HMETERS,
48X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3
5X,7HDEGREES,9X,7HVOLTS/M)
11 FORMAT (2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2)6X,E11.4)
12 FORMAT (///,35X,32H- - - NEAR MAGNETIC FIELDS - - -,//,12X,14H- L
1OCATION -,21X,8H- HX -,15X,8H- HY -,15X,8H- HZ -,10X,'- PEA
|K FIELDS -'/,8X,1HX,10X,
21HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHASE,
36X,9HMAGNITUDE,3X,5HPHASE,9X,9HMAGNITUDE/,6X,6HMETERS,5X,6HMETERS
|,5X,6HMETERS,
49X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7
5HDEGREES,9X,6HAMPS/M)
END
C
C
C
SUBROUTINE NEFLD (XOB,YOB,ZOB,EX,EY,EZ,LD,LD3,X,Y,Z,SI,BI,
1 SALP,CAB,SAB,T1X,T1Y,T1Z,T2X,T2Y,T2Z,ICON1,ICON2,AIR,
2 AII,BIR,BII,CIR,CII,CUR)
C
C NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
C THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
C
REAL*8 ZP,XI,XOB,YOB,ZOB,AIR,AII,BIR,BII,CIR,CII
CLARGE:CUR
COMPLEX CUR
COMPLEX*16 ACX,BCX,CCX,EX,EY,EZ
COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,
1 ZRATI,ZRATI2,T1,FRATI
INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM,IND1,IND2
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
COMMON/DATAJ/S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,
1 EZS,EXC,EYC,EZC,RKH,IND1,IND2,IPGND,IEXK
COMMON/GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,
1 IFAR,IPERF,T1,T2
DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
DIMENSION CUR(LD3),ICON1(LD),ICON2(LD)
DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),
1 CAB(LD),SAB(LD)
EQUIVALENCE (T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2Y
1J,IND1), (T2ZJ,IND2)
C**
C E WRITE(*,*) ' NEFLD: START'
C**
EX=(0.,0.)
EY=(0.,0.)
EZ=(0.,0.)
AX=0.
IF (N.EQ.0) GO TO 20
DO 1 I=1,N
XJ=XOB-X(I)
YJ=YOB-Y(I)
ZJ=ZOB-Z(I)
ZP=CAB(I)*XJ+SAB(I)*YJ+SALP(I)*ZJ
IF(DABS(ZP).GT.0.5001D0*SI(I)) GO TO 1
ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP
XJ=BI(I)
IF (ZP.GT.0.9*XJ*XJ) GO TO 1
AX=XJ
GO TO 2
1 CONTINUE
2 DO 19 I=1,N
S=SI(I)
B=BI(I)
XJ=X(I)
YJ=Y(I)
ZJ=Z(I)
CABJ=CAB(I)
SABJ=SAB(I)
SALPJ=SALP(I)
IF (IEXK.EQ.0) GO TO 18
IPR=ICON1(I)
IF (IPR) 3,8,4
3 IPR=-IPR
IF (-ICON1(IPR).NE.I) GO TO 9
GO TO 6
4 IF (IPR.NE.I) GO TO 5
IF (CABJ*CABJ+SABJ*SABJ.GT.1.E-8) GO TO 9
GO TO 7
5 IF (ICON2(IPR).NE.I) GO TO 9
C6 XI=DABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
6 XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
IF (XI.LT.0.999999D0) GO TO 9
IF (ABS(BI(IPR)/B-1.).GT.1.E-6) GO TO 9
7 IND1=0
GO TO 10
8 IND1=1
GO TO 10
9 IND1=2
10 IPR=ICON2(I)
IF (IPR) 11,16,12
11 IPR=-IPR
IF (-ICON2(IPR).NE.I) GO TO 17
GO TO 14
12 IF (IPR.NE.I) GO TO 13
IF (CABJ*CABJ+SABJ*SABJ.GT.1.E-8) GO TO 17
GO TO 15
13 IF (ICON1(IPR).NE.I) GO TO 17
C14 XI=DABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
14 XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
IF (XI.LT.0.999999D0) GO TO 17
IF (ABS(BI(IPR)/B-1.).GT.1.E-6) GO TO 17
15 IND2=0
GO TO 18
16 IND2=1
GO TO 18
17 IND2=2
18 CONTINUE
CALL EFLD (XOB,YOB,ZOB,AX,1)
ACX=DCMPLX(AIR(I),AII(I))
BCX=DCMPLX(BIR(I),BII(I))
CCX=DCMPLX(CIR(I),CII(I))
EX=EX+EXK*ACX+EXS*BCX+EXC*CCX
EY=EY+EYK*ACX+EYS*BCX+EYC*CCX
19 EZ=EZ+EZK*ACX+EZS*BCX+EZC*CCX
IF (M.EQ.0) GOTO 22
20 JC=N
JL=LD+1
DO 21 I=1,M
JL=JL-1
S=BI(JL)
XJ=X(JL)
YJ=Y(JL)
ZJ=Z(JL)
T1XJ=T1X(JL)
T1YJ=T1Y(JL)
T1ZJ=T1Z(JL)
T2XJ=T2X(JL)
T2YJ=T2Y(JL)
T2ZJ=T2Z(JL)
JC=JC+3
ACX=T1XJ*CUR(JC-2)+T1YJ*CUR(JC-1)+T1ZJ*CUR(JC)
BCX=T2XJ*CUR(JC-2)+T2YJ*CUR(JC-1)+T2ZJ*CUR(JC)
DO 21 IP=1,KSYMP
IPGND=IP
CALL UNERE (XOB,YOB,ZOB)
EX=EX+ACX*EXK+BCX*EXS
EY=EY+ACX*EYK+BCX*EYS
EZ=EZ+ACX*EZK+BCX*EZS
21 CONTINUE
22 CONTINUE
C**
C E WRITE(*,*) ' NEFLD: RETURN'
C**
RETURN
END
C
C
C
SUBROUTINE NHFLD (XOB,YOB,ZOB,HX,HY,HZ,LD,LD3,X,Y,Z,SI,BI,
1 SALP,CAB,SAB,T1X,T1Y,T1Z,T2X,T2Y,T2Z,AIR,
2 AII,BIR,BII,CIR,CII,CUR)
C
C NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
C THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
C
REAL*8 XOB,YOB,ZOB,AIR,AII,BIR,BII,CIR,CII
CLARGE: CUR
COMPLEX CUR
COMPLEX*16 ACX,BCX,CCX,HX,HY,HZ
COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC
INTEGER*4 N1,N2,N,NP,M1,M2,M,MP,IPSYM,IND1,IND2
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
COMMON/DATAJ/S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,
1 EZS,EXC,EYC,EZC,RKH,IND1,IND2,IPGND,IEXK
DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
DIMENSION CUR(LD3)
DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),
1 CAB(LD),SAB(LD)
EQUIVALENCE (T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2Y
1J,IND1), (T2ZJ,IND2)
C**
C E WRITE(*,*) ' NHFLD: RETURN'
C**
HX=(0.,0.)
HY=(0.,0.)
HZ=(0.,0.)
AX=0.
IF (N.EQ.0) GO TO 4
DO 1 I=1,N
XJ=XOB-X(I)
YJ=YOB-Y(I)
ZJ=ZOB-Z(I)
ZP=CAB(I)*XJ+SAB(I)*YJ+SALP(I)*ZJ
IF (ABS(ZP).GT.0.5001*SI(I)) GO TO 1
ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP
XJ=BI(I)
IF (ZP.GT.0.9*XJ*XJ) GO TO 1
AX=XJ
GO TO 2
1 CONTINUE
2 DO 3 I=1,N
S=SI(I)
B=BI(I)
XJ=X(I)
YJ=Y(I)
ZJ=Z(I)
CABJ=CAB(I)
SABJ=SAB(I)
SALPJ=SALP(I)
CALL HSFLD (XOB,YOB,ZOB,AX)
ACX=DCMPLX(AIR(I),AII(I))
BCX=DCMPLX(BIR(I),BII(I))
CCX=DCMPLX(CIR(I),CII(I))
HX=HX+EXK*ACX+EXS*BCX+EXC*CCX
HY=HY+EYK*ACX+EYS*BCX+EYC*CCX
3 HZ=HZ+EZK*ACX+EZS*BCX+EZC*CCX
IF (M.EQ.0) GOTO 6
4 JC=N
JL=LD+1
DO 5 I=1,M
JL=JL-1
S=BI(JL)
XJ=X(JL)
YJ=Y(JL)
ZJ=Z(JL)
T1XJ=T1X(JL)
T1YJ=T1Y(JL)
T1ZJ=T1Z(JL)
T2XJ=T2X(JL)
T2YJ=T2Y(JL)
T2ZJ=T2Z(JL)
CALL HINTG (XOB,YOB,ZOB)
JC=JC+3
ACX=T1XJ*CUR(JC-2)+T1YJ*CUR(JC-1)+T1ZJ*CUR(JC)
BCX=T2XJ*CUR(JC-2)+T2YJ*CUR(JC-1)+T2ZJ*CUR(JC)
HX=HX+ACX*EXK+BCX*EXS
HY=HY+ACX*EYK+BCX*EYS
HZ=HZ+ACX*EZK+BCX*EZS
5 CONTINUE
6 CONTINUE
C**
C E WRITE(*,*) ' NHFLD: RETURN'
C**
RETURN
END
C
C
C
SUBROUTINE EFLD (XI,YI,ZI,AI,IJ)
C
C COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND
C CONSTANT CURRENTS. GROUND EFFECT INCLUDED.
C
INTEGER*4 IND1,IND2
REAL*8 PI,TP,R,RMAG,XYMAG,XSPEC,YSPEC,RHOSPC,CTH,PX,PY,DMIN,
1 SHAF,XI,YI,ZI
COMPLEX*16 EGND(9),TXK,TYK,TZK,TXS,TYS,TZS,TXC,TYC,TZC,
1 TEZS,TERS,TEZC,TERC,TEZK,TERK
COMPLEX*16 EXK,EYK,EZK,EXS,EYS,ZRATI,ZRATI2,T1,FRATI,
1 EZS,EXC,EYC,EZC,EPX,EPY,REFS,REFPS,ZRSIN,ZRATX,ZSCRN
COMMON/DATAJ/S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,
1 EZS,EXC,EYC,EZC,RKH,IND1,IND2,IPGND,IEXK
COMMON/GND/ ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,
1 IFAR,IPERF,T1,T2
COMMON/INCOM/ XO,YO,ZO,SN,XSN,YSN,ISNOR
EQUIVALENCE (EGND(1),TXK),(EGND(2),TYK),(EGND(3),TZK),(EGND(4),
1TXS),(EGND(5),TYS),(EGND(6),TZS),(EGND(7),TXC),(EGND(8),TYC),
2(EGND(9),TZC)
DATA ETA/376.73/,PI/3.141592654D0/,TP/6.283185308D0/
C**
C D WRITE(*,*) ' EFLD: START'
C**
XIJ=XI-XJ
YIJ=YI-YJ
IJX=IJ
RFL=-1.
DO 12 IP=1,KSYMP
IF (IP.EQ.2) IJX=1
RFL=-RFL
SALPR=SALPJ*RFL
ZIJ=ZI-RFL*ZJ
ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR
RHOX=XIJ-CABJ*ZP
RHOY=YIJ-SABJ*ZP
RHOZ=ZIJ-SALPR*ZP
C RH=DSQRT(RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ+AI*AI)
RH=SQRT(RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ+AI*AI)
IF (RH.GT.1.E-10) GO TO 1
RHOX=0.
RHOY=0.
RHOZ=0.
GO TO 2
1 RHOX=RHOX/RH
RHOY=RHOY/RH
RHOZ=RHOZ/RH
C2 R=DSQRT(ZP*ZP+RH*RH)
2 R=SQRT(ZP*ZP+RH*RH)
IF (R.LT.RKH) GO TO 3
C
C LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS
C
RMAG=TP*R
CTH=ZP/R
PX=RH/R
TXK=DCMPLX(DCOS(RMAG),-DSIN(RMAG))
PY=TP*R*R
TYK=ETA*CTH*TXK*DCMPLX(1.,-1./RMAG)/PY
TZK=ETA*PX*TXK*DCMPLX(1.,RMAG-1./RMAG)/(2.*PY)
TEZK=TYK*CTH-TZK*PX
TERK=TYK*PX+TZK*CTH
RMAG=DSIN(PI*S)/PI
TEZC=TEZK*RMAG
TERC=TERK*RMAG
TEZK=TEZK*S
TERK=TERK*S
TXS=(0.,0.)
TYS=(0.,0.)
TZS=(0.,0.)
GO TO 6
3 IF (IEXK.EQ.1) GO TO 4
C
C EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX.
C
CALL EKSC (S,ZP,RH,TP,IJX,TEZS,TERS,TEZC,TERC,TEZK,TERK)
GO TO 5
4 CONTINUE
CALL EKSCX(B,S,ZP,RH,TP,IJX,IND1,IND2,TEZS,TERS,TEZC,TERC,TEZK,
1TERK)
5 TXS=TEZS*CABJ+TERS*RHOX
TYS=TEZS*SABJ+TERS*RHOY
TZS=TEZS*SALPR+TERS*RHOZ
6 TXK=TEZK*CABJ+TERK*RHOX
TYK=TEZK*SABJ+TERK*RHOY
TZK=TEZK*SALPR+TERK*RHOZ
TXC=TEZC*CABJ+TERC*RHOX
TYC=TEZC*SABJ+TERC*RHOY
TZC=TEZC*SALPR+TERC*RHOZ
IF (IP.NE.2) GO TO 11
IF (IPERF.GT.0) GO TO 10
ZRATX=ZRATI
RMAG=R
C XYMAG=DSQRT(XIJ*XIJ+YIJ*YIJ)
XYMAG=SQRT(XIJ*XIJ+YIJ*YIJ)
C
C SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.
C
IF (NRADL.EQ.0) GO TO 7
XSPEC=(XI*ZJ+ZI*XJ)/(ZI+ZJ)
YSPEC=(YI*ZJ+ZI*YJ)/(ZI+ZJ)
RHOSPC=DSQRT(XSPEC*XSPEC+YSPEC*YSPEC+T2*T2)
IF (RHOSPC.GT.SCRWL) GO TO 7
ZSCRN=T1*RHOSPC*DLOG(RHOSPC/T2)
ZRATX=(ZSCRN*ZRATI)/(ETA*ZRATI+ZSCRN)
7 IF (XYMAG.GT.1.D-6) GO TO 8
C
C CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.
C
PX=0.
PY=0.
CTH=1.
ZRSIN=(1.,0.)
GO TO 9
8 PX=-YIJ/XYMAG
PY=XIJ/XYMAG
CTH=ZIJ/RMAG
ZRSIN=CDSQRT(1.-ZRATX*ZRATX*(1.-CTH*CTH))
9 REFS=(CTH-ZRATX*ZRSIN)/(CTH+ZRATX*ZRSIN)
REFPS=-(ZRATX*CTH-ZRSIN)/(ZRATX*CTH+ZRSIN)
REFPS=REFPS-REFS
EPY=PX*TXK+PY*TYK
EPX=PX*EPY
EPY=PY*EPY
TXK=REFS*TXK+REFPS*EPX
TYK=REFS*TYK+REFPS*EPY
TZK=REFS*TZK
EPY=PX*TXS+PY*TYS
EPX=PX*EPY
EPY=PY*EPY
TXS=REFS*TXS+REFPS*EPX
TYS=REFS*TYS+REFPS*EPY
TZS=REFS*TZS
EPY=PX*TXC+PY*TYC
EPX=PX*EPY
EPY=PY*EPY
TXC=REFS*TXC+REFPS*EPX
TYC=REFS*TYC+REFPS*EPY
TZC=REFS*TZC
10 EXK=EXK-TXK*FRATI
EYK=EYK-TYK*FRATI
EZK=EZK-TZK*FRATI
EXS=EXS-TXS*FRATI
EYS=EYS-TYS*FRATI
EZS=EZS-TZS*FRATI
EXC=EXC-TXC*FRATI
EYC=EYC-TYC*FRATI
EZC=EZC-TZC*FRATI
GO TO 12
11 EXK=TXK
EYK=TYK
EZK=TZK
EXS=TXS
EYS=TYS
EZS=TZS
EXC=TXC
EYC=TYC
EZC=TZC
12 CONTINUE
IF (IPERF.EQ.2) GO TO 13
C**
C D WRITE(*,*) ' EFLD: RETURN LINE 161'
C**
RETURN
C
C FIELD DUE TO GROUND USING SOMMERFELD/NORTON
C
C13 SN=DSQRT(CABJ*CABJ+SABJ*SABJ)
13 SN=SQRT(CABJ*CABJ+SABJ*SABJ)
IF (SN.LT.1.E-5) GO TO 14
XSN=CABJ/SN
YSN=SABJ/SN
GO TO 15
14 SN=0.
XSN=1.
YSN=0.
C
C DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION
C
15 ZIJ=ZI+ZJ
SALPR=-SALPJ
RHOX=SABJ*ZIJ-SALPR*YIJ
RHOY=SALPR*XIJ-CABJ*ZIJ
RHOZ=CABJ*YIJ-SABJ*XIJ
RH=RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ
IF (RH.GT.1.E-10) GO TO 16
XO=XI-AI*YSN
YO=YI+AI*XSN
ZO=ZI
GO TO 17
C16 RH=AI/DSQRT(RH)
16 RH=AI/SQRT(RH)
IF (RHOZ.LT.0.) RH=-RH
XO=XI+RH*RHOX
YO=YI+RH*RHOY
ZO=ZI+RH*RHOZ
17 R=XIJ*XIJ+YIJ*YIJ+ZIJ*ZIJ
IF (R.GT..95) GO TO 18
C
C FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT
C
ISNOR=1
DMIN=EXK*DCONJG(EXK)+EYK*DCONJG(EYK)+EZK*DCONJG(EZK)
DMIN=.01*DSQRT(DMIN)
SHAF=.5*S
CALL ROM2 (-SHAF,SHAF,EGND,DMIN)
GO TO 19
C
C NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION
C
18 ISNOR=2
CALL SFLDS (0.D0,EGND)
GO TO 22
19 ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR
RH=R-ZP*ZP
IF (RH.GT.1.E-10) GO TO 20
DMIN=0.
GO TO 21
C20 DMIN=DSQRT(RH/(RH+AI*AI))
20 DMIN=SQRT(RH/(RH+AI*AI))
21 IF (DMIN.GT..95) GO TO 22
PX=1.-DMIN
TERK=(TXK*CABJ+TYK*SABJ+TZK*SALPR)*PX
TXK=DMIN*TXK+TERK*CABJ
TYK=DMIN*TYK+TERK*SABJ
TZK=DMIN*TZK+TERK*SALPR
TERS=(TXS*CABJ+TYS*SABJ+TZS*SALPR)*PX
TXS=DMIN*TXS+TERS*CABJ
TYS=DMIN*TYS+TERS*SABJ
TZS=DMIN*TZS+TERS*SALPR
TERC=(TXC*CABJ+TYC*SABJ+TZC*SALPR)*PX
TXC=DMIN*TXC+TERC*CABJ
TYC=DMIN*TYC+TERC*SABJ
TZC=DMIN*TZC+TERC*SALPR
22 EXK=EXK+TXK
EYK=EYK+TYK
EZK=EZK+TZK
EXS=EXS+TXS
EYS=EYS+TYS
EZS=EZS+TZS
EXC=EXC+TXC
EYC=EYC+TYC
EZC=EZC+TZC
C**
C D WRITE(*,*) ' EFLD: RETURN LINE 241'
C**
RETURN
END